home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM BV3 / BMUG PD-ROM Version BV3 (CDRM1097900).iso / Programming / Programming Languages / Pocket Forth 6 / Examples / Misc < prev    next >
Encoding:
Text File  |  1992-05-23  |  2.6 KB  |  66 lines  |  [TEXT/McSk]
  1. ( Misc extras for Pocket Forth 0.6 ) decimal
  2.  
  3. : 00>R ( rstack: -- 0 0 ) ,$ 42A7 ; macro  ( clr.l -[rs] )
  4. : 2R ( -- d ) ( rstack: d -- d )
  5.     ,$ 2D17 ; macro  ( move.l [rs],-[ps] )
  6.  
  7. : SP! ( -- ) s0@ ,$ 2C5E ;  ( move.l [ps]+,ps ) ( reset pstack )
  8. : RP! ( -- ) r0@ ,$ 2E5E ;  ( move.l [ps]+,rs ) ( reset rstack )
  9.  
  10. : NIP ( n1 n2 -- n2 ) ,$ 3C9E ; macro  ( move [ps]+,[ps] )
  11. : TUCK ( n1 n2 -- n2 n1 n2 ) swap over ;
  12.  
  13. : 2- ( n -- n-2 ) ,$ 5556 ; macro  ( subq #2,[ps] )
  14. : 4+ ( n -- n+4 ) ,$ 5856 ; macro  ( addq #4,[ps] )
  15.  
  16. : RANDOM ( n -- n' ) ( random number from 0 to n )
  17.     0 >r ,$ A861  r> ( _Random )
  18.     swap 32768 */ abs ;  ( scale to size from stack )
  19.  
  20. : ?COLOR ( -- f ) ( true if color is available [system6+] )
  21.     ,$ 204A   ( movea.l a2,a0 )
  22.     ,$ 7001   ( moveq.l #$01,d0 )
  23.     ,$ A090   ( _SysEnvirons )
  24.     here 9 + c@ ;  ( color qd available? )
  25.  
  26. : SSIZE ( -- h v )  ( screen size in pixels )
  27.     ,$ 2d2d ,$ ff8c ; macro  ( move.l screenBits[a5],-[ps] )
  28.  
  29. : .ALERT ( resource.ID -- dismissing.item.number )
  30.     ,$ 4267  >r ,$ 42a7  ( clr -[a7]  move [a6]+,-[a7]  clr.l -[a7] )
  31.     ,$ a985  r> ;        ( _Alert  move [a7]+,-[a7] )
  32.     
  33. : >CLIP ( c -- ) ( put a character on the clipboard )
  34.     256 *  ( move ascii data into byte position )
  35.     00>r ,$ A9FC 2r> 2drop  ( _ZeroScrap )
  36.     00>r  1 0 2>r  ,s TEXT 2>r  sp@ 2>r  ,$ A9FE  ( _PutScrap )
  37.     2r> + IF beep THEN ;  ( beep on error )
  38.  
  39. : GROW ( -- ) ( increase free space ) ( WARNING: default at maximum )
  40.     [ ' save 42 + literal ] execute ; ( no longer in dictionary )
  41.  
  42. : EVEN ( n -- n' ) dup 2 mod + ;  ( round up to even number )
  43. : ," ( -- ) ( compile a quoted string from input stream )
  44.     34 word here c@ 1+ even allot ; IMMEDIATE
  45.  
  46. ( Display relative addresses in hex )
  47. : SPACES ( n -- ) 0 DO space LOOP ;  ( emit n spaces )
  48. : H.2 ( n -- ) ( print a hex number )
  49.     base @ >r hex  dup 16 < IF
  50.       0 . 8 emit THEN  .  r> base ! ;
  51. : A. ( addr -- ) h.2 8 emit ." :" 2 spaces ;  ( print addr )
  52. : DUMP ( addr len -- ) ( do a formatted hex dump of memory )
  53.     swap dup -16 and swap dup a. over -  ( round start addr )
  54.     dup 0 DO 3 spaces LOOP ."  |"  rot +  ( indicate start addr )
  55.     over cr a.  0 DO  ( do for each len+[rounded.addr - real.addr])
  56.       dup r + c@ h.2  ( print byte value at addr + index )
  57.       r 1+ 16 mod 0= IF  ( break at end of 16 byte line )
  58.         ( 2 spaces dup r + 15 - 16 type  ( type the line ) ( long )
  59.         dup r + 1+ cr a. THEN LOOP  ( start a new line )
  60.     drop cr ;
  61.  
  62. room  page
  63. ( You have just loaded several utility words.)
  64. ( Examine them in the Misc file for more info).
  65. ( bytes of dictionary left. )
  66.